home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p1 / Runtime (.c & .h) / load.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-07-26  |  18.3 KB  |  719 lines  |  [TEXT/KAHL]
  1. /* Loading of .O files */
  2.  
  3. #include "params.h"
  4. #include "gambit.h"
  5. #include "struct.h"
  6. #include "os.h"
  7. #include "mem.h"
  8. #include "strings.h"
  9. #include "opcodes.h"
  10. #include "run.h"
  11. #include "stats.h"
  12. #include "emul.h"
  13.  
  14.  
  15. /*---------------------------------------------------------------------------*/
  16.  
  17.  
  18. struct patch_rec {
  19.   struct patch_rec *next; /* next entry in the patch list    */
  20.   long index;             /* index to value's source         */
  21.   SCM_obj *loc;           /* pointer to location to patch to */
  22.   };
  23.  
  24. typedef struct patch_rec *PATCH_PTR;
  25.  
  26.  
  27. char *alloc_ptr, *read_bot, *read_top, *load_bot, *load_top, *load_ptr;
  28. SCM_obj *object;
  29. PATCH_PTR free_patches, prim_patches;
  30. char *filename, *procedure_name;
  31.  
  32.  
  33. char *alloc( len )
  34. long len;
  35. { long len2 = ceiling8( len );
  36.   if (alloc_ptr-len2 < read_top)
  37.   { os_err = "Load memory overflow"; return NULL; }
  38.   alloc_ptr -= len2;
  39.   return alloc_ptr;
  40. }
  41.  
  42.  
  43. long begin_load()
  44. { free_patches = NULL;
  45.   prim_patches = NULL;
  46.   read_bot = pstate->heap_old;
  47.   alloc_ptr = read_bot + (pstate->heap_mid - pstate->heap_bot);
  48.   read_top = read_bot;
  49.   object = (SCM_obj *)alloc( sizeof(SCM_obj) * (long)MAX_NB_OBJECTS_PER_FILE );
  50.   return (object == NULL);
  51. }
  52.  
  53.  
  54. long end_load()
  55. { PATCH_PTR patch = prim_patches;
  56.   while (patch != NULL)
  57.   { SCM_obj val = sstate->globals[patch->index].value;
  58.     if (val == (long)SCM_unbound)
  59.     { os_err = string_append( "Undefined primitive, ",
  60.                               global_name(patch->index) );
  61.       return 1;
  62.     }
  63.     *(patch->loc) += val; /* patch up reference to the primitive */
  64.     patch = patch->next;
  65.   }
  66.   return 0;
  67. }
  68.  
  69.  
  70. long eof()
  71. { os_err = "Premature EOF";
  72.   return 1;
  73. }
  74.  
  75.  
  76. #define load_long_word(var) \
  77. { if (load_ptr+4>load_top) return eof(); var = *(long *)load_ptr; load_ptr += 4; }
  78.  
  79. #define load_word(var) \
  80. { if (load_ptr+2>load_top) return eof(); var = *(short *)load_ptr; load_ptr += 2; }
  81.  
  82. #define load_words( n, ptr ) \
  83. { register long i = (n); register short *pt = (ptr); \
  84.   if (load_ptr + i*2 > load_top) return eof(); \
  85.   while (i>0) { *(pt++) = *(short *)load_ptr; load_ptr += 2; i--; } \
  86. }
  87.  
  88.  
  89. long load_string( str )
  90. char **str;
  91. { *str = load_ptr;
  92.   while (*(load_ptr++) != '\0') if (load_ptr > load_top) return eof();
  93.   load_ptr = (char *)ceiling2( load_ptr );
  94.   if (load_ptr > load_top) return eof();
  95.   return 0;
  96. }
  97.  
  98.  
  99. long skip_string( offset )
  100. long *offset;
  101. { *offset = load_ptr - load_bot;
  102.   while (*(load_ptr++) != '\0') if (load_ptr > load_top) return eof();
  103.   load_ptr = (char *)ceiling2( load_ptr );
  104.   if (load_ptr > load_top) return eof();
  105.   return 0;
  106. }
  107.  
  108.  
  109. /*---------------------------------------------------------------------------*/
  110.  
  111.  
  112. long nb_objects, highest_object, nb_symbols;
  113. PATCH_PTR object_patches, M68020_patches, M68881_patches;
  114.  
  115.  
  116. long add_object( value )
  117. SCM_obj value;
  118. { long i = nb_objects++;
  119.   if (i + nb_symbols >= (long)MAX_NB_OBJECTS_PER_FILE)
  120.   { os_err = "Too many objects in an object file"; return 1; }
  121.   object[i] = value;
  122.   return 0;
  123. }
  124.  
  125.  
  126. long add_patch( list, index, loc )
  127. PATCH_PTR *list;
  128. long index;
  129. SCM_obj *loc;
  130. { PATCH_PTR patch;
  131.   if (free_patches != NULL)
  132.   { patch = free_patches;
  133.     free_patches = free_patches->next;
  134.   }
  135.   else
  136.   { patch = (PATCH_PTR)alloc( (long)sizeof(struct patch_rec) );
  137.     if (patch == NULL) return 1;
  138.   }
  139.   patch->next  = *list;
  140.   patch->index = index;
  141.   patch->loc   = loc;
  142.   *list        = patch;
  143.   return 0;
  144. }
  145.  
  146.  
  147. long add_prim_patch( index, loc )
  148. long index;
  149. SCM_obj *loc;
  150. { return add_patch( &prim_patches, index, loc );
  151. }
  152.  
  153.  
  154. long add_object_patch( index, loc )
  155. long index;
  156. SCM_obj *loc;
  157. { if (index + nb_symbols >= (long)MAX_NB_OBJECTS_PER_FILE)
  158.   { os_err = "Object reference too big"; return 1; }
  159.   if (index > highest_object) highest_object = index;
  160.   return add_patch( &object_patches, index, loc );
  161. }
  162.  
  163.  
  164. long patchup_M68020_emul_code()
  165. { PATCH_PTR patch = M68020_patches;
  166.   while (patch != NULL)
  167.   { PATCH_PTR next = patch->next;
  168.     if (emul_M68020_instr( (short *)patch->loc )) return 1;
  169.     patch->next = free_patches;
  170.     free_patches = patch;
  171.     patch = next;
  172.   }
  173.   return 0;
  174. }
  175.  
  176.  
  177. long patchup_M68881_emul_code()
  178. { PATCH_PTR patch = M68881_patches;
  179.   while (patch != NULL)
  180.   { PATCH_PTR next = patch->next;
  181.     if (emul_M68881_instr( (short *)patch->loc )) return 1;
  182.     patch->next = free_patches;
  183.     free_patches = patch;
  184.     patch = next;
  185.   }
  186.   return 0;
  187. }
  188.  
  189.  
  190. long load_sym( i, loc )
  191. short i;
  192. SCM_obj *loc;
  193. { if (i == INDEX_MASK)
  194.   { char *name;
  195.     long j = nb_symbols++;
  196.     if (j + nb_objects >= (long)MAX_NB_OBJECTS_PER_FILE)
  197.     { os_err = "Too many symbols in an object file"; return 1; }
  198.     if (load_string( &name )) return 1;
  199.     if (alloc_symbol( name, loc )) return 1;
  200.     object[MAX_NB_OBJECTS_PER_FILE-1-j] = *loc;
  201.    }
  202.   else if (i > nb_symbols)
  203.   { os_err = "Symbol reference out of range"; return 1; }
  204.   else
  205.     *loc = object[MAX_NB_OBJECTS_PER_FILE-1-i];
  206.   return 0;
  207. }
  208.  
  209.  
  210. long load_value( loc )
  211. SCM_obj *loc;
  212. { long val, masked;
  213.   load_long_word( val );
  214.   masked = val & ~(((long)INDEX_MASK) << 3);
  215.   if (masked == (long)OBJECT)
  216.   { *loc = (SCM_obj)0;
  217.     if (add_object_patch( (val >> 3) & INDEX_MASK, loc )) return 1;
  218.   }
  219.   else if (masked == (long)SYMBOL)
  220.   { if (load_sym( (short)((val >> 3) & INDEX_MASK), loc )) return 1;
  221.   }
  222.   else if (masked == (long)PRIM_PROC)
  223.   { SCM_obj sym;
  224.     long index;
  225.     if (load_sym( (short)((val >> 3) & INDEX_MASK), &sym )) return 1;
  226.     if (alloc_global_from_symbol( sym, &index )) return 1;
  227.     if (add_prim_patch( index, loc )) return 1;
  228.     *loc = (SCM_obj)0;
  229.   }
  230.   else
  231.     *loc = (SCM_obj)val;
  232.   return 0;
  233. }
  234.  
  235.  
  236. long load_proc( proc_adr, len, name )
  237. SCM_obj proc_adr;
  238. long len;
  239. char *name;
  240. { short *code_ptr = (short *)proc_adr;
  241.  
  242.   procedure_name = name;
  243.  
  244.   M68020_patches = NULL;
  245.   M68881_patches = NULL;
  246.  
  247.   while (1)
  248.   { short tag;
  249.  
  250.     load_word( tag );
  251.  
  252.     if (tag > 0)
  253.     { load_words( tag, code_ptr );
  254.       code_ptr += tag;
  255.     }
  256.  
  257.     else if (tag == (short)PADDING_TAG)
  258.       /* just skip */;
  259.  
  260.     else if (tag == (short)END_OF_CODE_TAG)
  261.       break;
  262.  
  263.     else if (tag == (short)M68020_TAG)
  264.     { if (!os_M68020)
  265.         if (add_patch( &M68020_patches, 0L, (SCM_obj *)code_ptr )) return 1;
  266.     }
  267.  
  268.     else if (tag == (short)M68881_TAG)
  269.     { if (!os_M68881)
  270.         if (add_patch( &M68881_patches, 0L, (SCM_obj *)code_ptr )) return 1;
  271.     }
  272.  
  273.     else if (tag == (short)STAT_TAG)
  274.     { long index;
  275.       if (alloc_stat( &index ))
  276.       { os_err = "Statistics table overflow"; return 1; }
  277.       else
  278.       { *(long **)code_ptr = &pstate->stats_counters[index];
  279.         code_ptr += 2;
  280.         if (skip_string( &sstate->stats_offsets[index] )) return 1;
  281.       }
  282.     }
  283.  
  284.     else
  285.     { short i = tag & INDEX_MASK;
  286.       tag = tag & ~INDEX_MASK;
  287.  
  288.       if (tag == (short)PROC_REF_TAG)
  289.       { if (add_object_patch( (long)i, (SCM_obj *)code_ptr )) return 1;
  290.         load_word( *(long *)code_ptr );
  291.         code_ptr += 2;
  292.       }
  293.  
  294.       else if (tag == (short)GLOBAL_VAR_REF_TAG)
  295.       { SCM_obj sym;
  296.         long index;
  297.         if (load_sym( i, &sym )) return 1;
  298.         if (alloc_global_from_symbol( sym, &index )) return 1;
  299.         *(code_ptr++) = table_offset( &sstate->globals[index].value );
  300.       }
  301.  
  302.       else if (tag == (short)GLOBAL_VAR_SET_TAG)
  303.       { SCM_obj sym;
  304.         long index;
  305.         if (load_sym( i, &sym )) return 1;
  306.         if (alloc_global_from_symbol( sym, &index )) return 1;
  307.         *(code_ptr++) = table_offset( &sstate->globals[index].value );
  308.         *(code_ptr++) = LEAA6_DISP_A1_OP;
  309.         *(code_ptr++) = table_offset( &sstate->tramps[index] );
  310.         *(code_ptr++) = MOVE_L_A1_A6_DISP_OP;
  311.         *(code_ptr++) = table_offset( &sstate->globals[index].jump_adr );
  312.       }
  313.  
  314.       else if (tag == (short)GLOBAL_VAR_REF_JUMP_TAG)
  315.       { SCM_obj sym;
  316.         long index;
  317.         if (load_sym( i, &sym )) return 1;
  318.         if (alloc_global_from_symbol( sym, &index )) return 1;
  319.         *(code_ptr++) = table_offset( &sstate->globals[index].jump_adr );
  320.       }
  321.  
  322.       else if (tag == (short)PRIM_REF_TAG)
  323.       { SCM_obj sym;
  324.         long index;
  325.         if (load_sym( i, &sym )) return 1;
  326.         if (alloc_global_from_symbol( sym, &index )) return 1;
  327.         if (add_prim_patch( index, (SCM_obj *)code_ptr )) return 1;
  328.         load_word( *(long *)code_ptr );
  329.         code_ptr += 2;
  330.       }
  331.  
  332.       else
  333.       { os_err = "Procedure object format error"; return 1; }
  334.     }
  335.  
  336.   }
  337.  
  338.   { long i, rest = len - ( ((long)code_ptr) - ((long)proc_adr) - 2 );
  339.     if ((rest < 0L) || ((rest & 3L) != 0))
  340.     { os_err = "Procedure object format error"; return 1; }
  341.     for (i=rest/4; i>0; i--)
  342.     { if (load_value( (SCM_obj *)code_ptr )) return 1;
  343.       code_ptr += 2;
  344.     }
  345.   }
  346.  
  347.   /* do patchup for emulation code */
  348.  
  349.   if (patchup_M68020_emul_code()) return 1;
  350.  
  351.   if (patchup_M68881_emul_code()) return 1;
  352.  
  353.   procedure_name = NULL;
  354.   return 0;
  355. }
  356.  
  357.  
  358. long load_mem( index, ptr, len, init_proc )
  359. long index;
  360. char *ptr;
  361. long len;
  362. SCM_obj *init_proc;
  363. { short version_major, version_minor;
  364.   char *emul_code_start = pstate->emul_code_ptr;
  365.  
  366.   emul_code_top   = pstate->emul_code_top;
  367.   emul_code_alloc = emul_code_start;
  368.  
  369.   load_bot = ptr;
  370.   load_top = ptr+len;
  371.   load_ptr = ptr;
  372.  
  373.   nb_objects = 0;
  374.   nb_symbols = 0;
  375.   highest_object = -1;
  376.   object_patches = NULL;
  377.   stats_begin( index );
  378.  
  379.   load_word( version_major );
  380.   if (version_major < OFILE_VERSION_MAJOR)
  381.   { os_err = "Old object file format"; return 1; }
  382.   else if (version_major > OFILE_VERSION_MAJOR)
  383.   { os_err = "New object file format"; return 1; }
  384.   load_word( version_minor );
  385.  
  386.   while (load_ptr+4 <= load_top)
  387.   { long prefix;
  388.     load_long_word( prefix );
  389.  
  390.     switch (prefix)
  391.     {
  392.       case (long)PRIM_PROC_PREFIX:
  393.       { SCM_obj adr, sym;
  394.         long indx, l;
  395.         short header, i;
  396.         char *name;
  397.         load_word( i );
  398.         if (load_sym( i, &sym )) return 1;
  399.         if (alloc_global_from_symbol( sym, &indx )) return 1;
  400.         name = SCM_obj_to_str(SCM_obj_to_vect(sym)[SYMBOL_NAME]);
  401.         load_word( header );
  402.         if (header >= 0)
  403.         { os_err = "Object file format error"; return 1; }
  404.         l = header + 0x8000;
  405.         if (sstate->debug>=2)
  406.         { os_warn( "  (primitive procedure %s", (long)name );
  407.           os_warn( ", length=%d)\n", l );
  408.         }
  409.         if (alloc_const_proc( l, &adr )) return 1;
  410.         if (add_object( adr )) return 1;
  411.         if (load_proc( adr, l, name )) return 1;
  412.         if ((sstate->debug>=2) &&
  413.             (sstate->globals[indx].value != (long)SCM_unbound))
  414.           os_warn( "Redefining %s\n", (long)name );
  415.         sstate->globals[indx].value    = adr;
  416.         sstate->globals[indx].jump_adr = (long)&sstate->tramps[indx];
  417.         break;
  418.       }
  419.  
  420.       case (long)USER_PROC_PREFIX:
  421.       { SCM_obj adr;
  422.         long l;
  423.         short header;
  424.         load_word( header );
  425.         if (header >= 0)
  426.         { os_err = "Object file format error"; return 1; }
  427.         l = header + 0x8000;
  428.         if (sstate->debug>=2) os_warn( "  (procedure, length=%d)\n", l );
  429.         if (alloc_const_proc( l, &adr )) return 1;
  430.         if (add_object( adr )) return 1;
  431.         if (load_proc( adr, l, (char *)NULL )) return 1;
  432.         break;
  433.       }
  434.  
  435.       case (long)PAIR_PREFIX:
  436.       { SCM_obj pair_adr;
  437.         if (sstate->debug>=2) os_warn( "  (pair)\n", 0L );
  438.         if (alloc_const_pair( &pair_adr )) return 1;
  439.         if (add_object( pair_adr )) return 1;
  440.         if (load_value( (SCM_obj *)(pair_adr-SCM_type_PAIR+PAIR_CDR*sizeof(SCM_obj)) )) return 1;
  441.         if (load_value( (SCM_obj *)(pair_adr-SCM_type_PAIR+PAIR_CAR*sizeof(SCM_obj)) )) return 1;
  442.         break;
  443.       }
  444.  
  445.     default:
  446.     { SCM_obj vector_adr;
  447.       long l = SCM_header_length( prefix );
  448.       long subtype = SCM_header_subtype( prefix );
  449.       if (alloc_const_subtyped( l, subtype, &vector_adr )) return 1;
  450.       if (add_object( vector_adr )) return 1;
  451.  
  452.       if (SCM_subtype_is_ovector( subtype ))
  453.       { long i, n = l/4;
  454.         if (sstate->debug>=2)
  455.           os_warn( "  (object vector; length=%d)\n", n );
  456.         for (i=0; i<n; i++)
  457.           if (load_value( &SCM_obj_to_vect(vector_adr)[i] )) return 1;
  458.       }
  459.  
  460.       else
  461.  
  462.       { short *p = (short *)SCM_obj_to_vect(vector_adr);
  463.         if (sstate->debug>=2)
  464.           os_warn( "  (byte vector; length=%d)\n", l );
  465.         load_words( (l + 1)/2, p );
  466.       }
  467.  
  468.       break;
  469.     }
  470.     }
  471.   }
  472.  
  473.   if (nb_objects < 1) { os_err = "Object file is empty"; return 1; }
  474.  
  475.   stats_end( index );
  476.  
  477.   /* do patchup for local object references */
  478.  
  479.   if (highest_object >= nb_objects)
  480.   { os_err = "Unresolved local object reference(s)"; return 1; }
  481.  
  482.   { PATCH_PTR patch = object_patches;
  483.     while (patch != NULL)
  484.     { PATCH_PTR next = patch->next;
  485.       *(patch->loc) += object[patch->index];
  486.       patch->next = free_patches;
  487.       free_patches = patch;
  488.       patch = next;
  489.     }
  490.   }
  491.  
  492.   /* copy emulation code to all other processors */
  493.  
  494.   { long i;
  495.     long l = emul_code_alloc - emul_code_start;
  496.     for (i=SCM_obj_to_int(pstate->nb_processors)-1; i>=0; i--)
  497.     { PSTATE_PTR p = pstate->ps[i];
  498.       if (p != pstate)
  499.         os_block_copy( emul_code_start, p->emul_code_ptr, l );
  500.       p->emul_code_ptr += l;
  501.     }
  502.   }
  503.  
  504.   *init_proc = object[0];
  505.  
  506.   return 0;
  507. }
  508.  
  509.  
  510. long load_file( index, init_proc )
  511. long index;
  512. SCM_obj *init_proc;
  513. { OS_FILE input;
  514.   long len;
  515.  
  516.   filename = string_append( sstate->ofile[index].ptr, ".O" );
  517.   if (filename == NULL) { os_err = NULL; return 1; }
  518.   input = os_file_open_input( filename );
  519.   if (input == -1L) { os_err = "Can't open"; return 1; }
  520.   len = os_file_length( input );
  521.   if (len < 0L) { os_err = "Read error"; return 1; }
  522.   if (sstate->debug>=1)
  523.   { os_warn( "Loading %s", (long)filename );
  524.     os_warn( " (length=%d)\n", len );
  525.   }
  526.  
  527.   read_top = read_bot+len;
  528.   if (read_top > alloc_ptr)
  529.   { os_file_close( input ); os_err = "Load memory overflow"; return 1; }
  530.  
  531.   if (os_file_read( input, read_bot, len ) != len)
  532.   { os_file_close( input ); os_err = "Read error"; return 1; }
  533.  
  534.   os_file_close( input );
  535.  
  536.   if (load_mem( index, read_bot, len, init_proc )) return 1;
  537.  
  538.   filename = NULL;
  539.   return 0;
  540. }
  541.  
  542.  
  543. void fill_in_os_err()
  544. { char *fn, *pn, *em;
  545.   if (filename == NULL) fn = ""; else fn = string_append( filename, ": " );
  546.   if (procedure_name == NULL) pn = ""; else pn = string_append( procedure_name, ", " );
  547.   if (os_err == NULL) em = "Local memory overflow"; else em = os_err;
  548.   os_err = string_append( fn, string_append( pn, em ) );
  549.   if (os_err == NULL) os_err = "Local memory overflow";
  550. }
  551.  
  552.  
  553. long prepare_ofile( ptr, len )
  554. char *ptr;
  555. long len;
  556. { long i;
  557.   if (len == 0)
  558.   { for (i=0; i<sstate->nb_ofiles; i++)
  559.       if ((sstate->ofile[i].len == 0) &&
  560.           (string_compare( sstate->ofile[i].ptr, ptr ) == 0)) break;
  561.   }
  562.   else
  563.     i = sstate->nb_ofiles;
  564.  
  565.   if (i >= (long)MAX_NB_OFILES)
  566.   { os_err = "Too many object files"; return -1; }
  567.  
  568.   sstate->ofile[i].ptr = ptr;
  569.   sstate->ofile[i].len = len;
  570.   stats_clear( i );
  571.   if (i == sstate->nb_ofiles) sstate->nb_ofiles++;
  572.   return i;
  573. }
  574.  
  575.  
  576. void init_ofile( ptr, len )
  577. char *ptr;
  578. long len;
  579. { if (prepare_ofile( ptr, len ) < 0)
  580.   { os_warn( "%s\n", (long)os_err ); os_quit(); }
  581. }
  582.  
  583.  
  584. SCM_obj init_program( argc, argv, envp )
  585. long argc;
  586. char *argv[], *envp[];
  587. { long i;
  588.   long envc;
  589.   SCM_obj ev, av, ep;
  590.  
  591.   filename = NULL;
  592.   procedure_name = NULL;
  593.  
  594.   if (alloc_const_vector( sstate->nb_ofiles, &ev )) goto error;
  595.  
  596.   if (begin_load()) goto error;
  597.  
  598.   for (i=0; i<sstate->nb_ofiles; i++)
  599.     if (sstate->ofile[i].len == 0)
  600.     { if (load_file( i, &SCM_obj_to_vect(ev)[i] )) goto error; }
  601.     else
  602.     { if (load_mem( i,
  603.                     sstate->ofile[i].ptr,
  604.                     sstate->ofile[i].len,
  605.                     &SCM_obj_to_vect(ev)[i] )) goto error;
  606.     }
  607.  
  608.   if (end_load()) goto error;
  609.  
  610.   /* init trap trampolines */
  611.  
  612.   for (i=0; i<NB_TRAMPOLINE_TRAPS; i++)
  613.   { long index;
  614.     static char prefix[] = "###_kernel.trap_";
  615.     char name[sizeof(prefix)+2], *p1 = name, *p2 = prefix;
  616.     while (*p2 != '\0') *p1++ = *p2++;
  617.     if (i > 9) *p1++ = '0' + (i/10);
  618.     *p1++ = '0' + (i%10);
  619.     *p1++ = '\0';
  620.     if (alloc_global( name, &index )) goto error;
  621.     sstate->traps[i].jmp = JMP_OP;
  622.     sstate->traps[i].adr = sstate->globals[index].value;
  623.   }
  624.  
  625.   /* init interrupt trap */
  626.  
  627.   { long index;
  628.     if (alloc_global( "###_kernel.interrupt", &index )) goto error;
  629.     sstate->traps[intr_trap].jmp = JMP_OP;
  630.     sstate->traps[intr_trap].adr = sstate->globals[index].value;
  631.   }
  632.  
  633.   if (set_global( "##exec-vector", ev )) goto error;
  634.  
  635.   if (set_global( "##argc", SCM_int_to_obj(argc) )) goto error;
  636.  
  637.   if (alloc_const_vector( argc, &av )) goto error;
  638.   for (i=0; i<argc; i++)
  639.     if (alloc_const_string( argv[i], &SCM_obj_to_vect(av)[i] )) goto error;
  640.   if (set_global( "##argv", av )) goto error;
  641.  
  642.   envc = 0;
  643.   while (envp[envc] != NULL) envc++;
  644.   if (alloc_const_vector( envc, &ep )) goto error;
  645.   for (i=0; i<envc; i++)
  646.     if (alloc_const_string( envp[i], &SCM_obj_to_vect(ep)[i] )) goto error;
  647.   if (set_global( "##envp", ep )) goto error;
  648.  
  649.   return SCM_obj_to_vect(ev)[0];
  650.  
  651.   error:
  652.   fill_in_os_err();
  653.   os_warn( "%s\n", (long)os_err );
  654.   os_quit();
  655.   /*NOTREACHED*/
  656. }  
  657.  
  658.  
  659. long do_load_copy_code( id, ptr )
  660. long id;
  661. char *ptr;
  662. { if (id != SCM_obj_to_int(pstate->id))
  663.   { long len1 = ((long *)ptr)[0];
  664.     long len2 = ((long *)ptr)[1];
  665.     os_block_copy( ptr+2*sizeof(long), sstate->const_bptr - len1 , len1 );
  666.     os_block_copy( ptr+2*sizeof(long)+len1, sstate->const_tptr, len2 );
  667.   }
  668.   return 0;
  669. }
  670.  
  671.  
  672. long load_ofile( name, init_proc )
  673. char *name;
  674. SCM_obj *init_proc;
  675. { if (name != NULL) /* only one processor does the load */
  676.   { long index;
  677.     char *const_b = sstate->const_bptr;
  678.     char *const_t = sstate->const_tptr;
  679.  
  680.     os_err = "";
  681.  
  682.     filename = NULL;
  683.     procedure_name = NULL;
  684.  
  685.     index = prepare_ofile( name, 0L );
  686.     if (index < 0) goto error;
  687.  
  688.     if (begin_load()) goto error;
  689.  
  690.     if (load_file( index, init_proc )) goto error;
  691.  
  692.     if (end_load()) goto error;
  693.  
  694.     /* copy code to each processor */
  695.  
  696.     { long len1 = sstate->const_bptr - const_b;
  697.       long len2 = const_t - sstate->const_tptr;
  698.       if (len1+len2+2*sizeof(long) > pstate->heap_mid - pstate->heap_bot)
  699.         goto error;
  700.       ((long *)pstate->heap_old)[0] = len1;
  701.       ((long *)pstate->heap_old)[1] = len2;
  702.       os_block_copy( const_b, pstate->heap_old+2*sizeof(long), len1 );
  703.       os_block_copy( sstate->const_tptr, pstate->heap_old+2*sizeof(long)+len1, len2 );
  704.       return barrier_call( do_load_copy_code, (long)pstate->heap_old );
  705.     }
  706.  
  707.     error:
  708.     fill_in_os_err();
  709.     if (sstate->debug>=1) os_warn( "%s\n", (long)os_err );
  710.     *init_proc = c_str_to_string( os_err );
  711.     return barrier_call( do_return, 1L );
  712.   }
  713.   else
  714.     return barrier_service();
  715. }
  716.  
  717.  
  718. /*---------------------------------------------------------------------------*/
  719.